home *** CD-ROM | disk | FTP | other *** search
/ Languguage OS 2 / Languguage OS II Version 10-94 (Knowledge Media)(1994).ISO / a_utils / ffccflow / ffccflow.lha / ffccc+flow / ffccc / SUPMOR.f < prev    next >
Text File  |  1992-07-31  |  1KB  |  38 lines
  1.       SUBROUTINE SUPMOR(SLIST,NACC,FLACC,IS,NS,NOUT)
  2. *-----------------------------------------------------------------------
  3. *   
  4. *--- suppresses multiple entries in sorted table, logically ORs NAMTYP  
  5. *   
  6. *--- input  
  7. *    SLIST     list containing all names
  8. *    NACC      array to be re-arranged, and logically ORed  
  9. *    FLACC     if true, NACC is actually updated
  10. *    IS      start-1 of table in SNAMES, /ALCAZA/   
  11. *    NS      length of table
  12. *--- output 
  13. *    NOUT    new table length   
  14. *   
  15. *-----------------------------------------------------------------------
  16.       include 'PARAM.h' 
  17.       CHARACTER *(MXNMCH) SLIST(*)  
  18.       DIMENSION NACC(*) 
  19.       LOGICAL FLACC 
  20.       NQ=NS 
  21.       IF (NQ.LE.0)  THEN
  22.          NOUT=0 
  23.       ELSE  
  24.          NOUT=1 
  25.          DO 10 I=2,NQ   
  26.             IF (SLIST(IS+I).NE.SLIST(IS+NOUT))  THEN
  27.                NOUT=NOUT+1  
  28.                IF (I.NE.NOUT) THEN  
  29.                   SLIST(IS+NOUT)=SLIST(IS+I)
  30.                   IF(FLACC)  NACC(IS+NOUT)=NACC(IS+I)   
  31.                ENDIF
  32.             ELSEIF(FLACC)  THEN 
  33.                NACC(IS+NOUT)=IOR(NACC(IS+NOUT),NACC(IS+I))  
  34.             ENDIF   
  35.    10    CONTINUE   
  36.       ENDIF 
  37.       END   
  38.